home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / Wood / split-lfun.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  6.4 KB  |  157 lines  |  [TEXT/CCL2]
  1. ;;;-*- Mode: Lisp; Package: CCL -*-
  2.  
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;;
  5. ;; split-lfun.lisp
  6. ;; Code to split an lfun into pieces that WOOD knows how to save
  7. ;;
  8. ;; Copyright © 1992 Apple Computer, Inc. All rights reserved.
  9. ;; Permission is given to use, copy, and modify this software provided
  10. ;; that this copyright notice is attached to all derivative works.
  11. ;; This software is provided "as is". Apple makes no warranty or
  12. ;; representation, either express or implied, with respect to this software,
  13. ;; its quality, accuracy, merchantability, or fitness for a particular
  14. ;; purpose.
  15. ;;
  16.  
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  18. ;;
  19. ;; Modification History
  20. ;;
  21. ;; -------------- 0.5
  22. ;; 03/13/92 bill  New file
  23. ;;
  24.  
  25. (in-package :ccl)
  26.  
  27. (export '(split-lfun join-lfun))
  28.  
  29. (eval-when (:compile-toplevel :execute)
  30.   (require :lispequ))
  31.  
  32. ; Returns a list of length five: (imms icode linkmap bits attrib fasl-version)
  33. ; If you APPLY JOIN-LFUN to this list, you will get a copy of the lfun.
  34. ; Note that the icode & linkmap vectors are of type (array (unsigned-byte 16)).
  35. ; ccl::%make-lfun requires that they be of exactly that type.
  36. ; Code largely copied from fasl-dump-lfun-vector.
  37. ; Tested in 2.0f3c2
  38.  
  39. (defun split-lfun (lfun)
  40.   (let* ((lfunv (%lfun-vector lfun))
  41.          (lfunv-len (uvsize lfunv))
  42.          icode
  43.          (imm-count (%count-immrefs lfunv))
  44.          (imms nil)
  45.          (linkmap (make-array (ash imm-count 1) 
  46.                               :element-type '(signed-byte 16)
  47.                               :initial-element $lm_longimm))
  48.          (bits (lfun-bits lfun))
  49.          (attrib (lfun-attributes lfun)))
  50.     (declare (fixnum lfunv-len imm-count))
  51.     (if (logbitp $lfatr-slfunv-bit attrib)
  52.       ; swappable lfun-vectors have an extra longword at the end
  53.       (decf lfunv-len 2))
  54.     ; Skip the immediate map at the end of the lfun vector.
  55.     (do ((i (1- lfunv-len) (1- i)))
  56.         ((< i 0) (error "Immediate map took entire lfun"))
  57.       (decf lfunv-len)
  58.       (let ((word (uvref lfunv i)))
  59.         (declare (fixnum word))
  60.         (if (or (eql 0 (logand #xff word))
  61.                 (eql 0 (logand #xff00 word)))
  62.           (return))))
  63.     (decf lfunv-len  (/ $t_lfun 2))     ; skip the header.
  64.     (setq icode (make-array lfunv-len :element-type '(signed-byte 16)))
  65.     (do ((i 0 (1+ i))
  66.          (j (/ $t_lfun 2) (1+ j))
  67.          (immno -1)
  68.          (u-imm-count 0))
  69.         ((>= i lfunv-len) (setq imm-count u-imm-count))
  70.       (declare (fixnum i j))
  71.       (if (%immref-p i lfunv)
  72.         (multiple-value-bind (imm offset)
  73.                              (%nth-immediate lfunv (incf immno 1))
  74.           (let ((first-imm (memq imm imms))
  75.                 (v-immno u-imm-count))
  76.             (if first-imm
  77.               (setq v-immno (length (cdr first-imm)))
  78.               (progn
  79.                 (push imm imms)
  80.                 (incf u-imm-count)))
  81.             (setf (aref icode i) (or offset 0))
  82.             (setf (aref icode (1+ i)) v-immno)
  83.             (setf (aref linkmap (+ immno immno)) 
  84.                   (%immediate-offset lfunv immno))
  85.             (incf i)
  86.             (incf j)))
  87.         (setf (aref icode i) (uvref lfunv j))))
  88.     (list (make-array imm-count :initial-contents (nreverse imms))
  89.           icode linkmap bits attrib fasl-version)))
  90.  
  91.  
  92. (defvar *fasl-min-version* fasl-version)
  93. (defvar *fasl-max-version* fasl-version)
  94.  
  95. ; imms is a sequence of Lisp values, preferably of type (array t)
  96. ; icode is an array of opcodes, preferably of type (array (unsigned-byte 16)).
  97. ; linkmap is alternating (byte) offsets in icode and
  98. ; $lm_longimm's,  preferably of type (array (unsigned-byte 16)).
  99. ; bits is the LFUN-BITS of the function.
  100. ; attrib is its LFUN-ATTRIBUTES.
  101.  
  102. ; At each linkmap referenced offset in icode, there are two (16-bit)
  103. ; words: a constant to add to the immediate (offsets a symbol to its
  104. ; value cell or function entry) and the index in IMMS for the immediate
  105. ; that goes there. This function just calls %MAKE-LFUN after coercing the
  106. ; sequences to the correct type and doing a little error checking.
  107.  
  108. ; The list returned by split-lfun is taylor made to call join-lfun.
  109. ; (apply 'join-lfun (split-lfun #'split-lfun)) will get you a copy
  110. ; of #'split-lfun.
  111.  
  112. (defun join-lfun (imms icode linkmap bits attrib &optional (fver fasl-version))
  113.   (unless (<= *fasl-min-version* fver *fasl-max-version*)
  114.     (cerror "they're compatible. Stop bothering me with error messages."
  115.             "LFUN saved with FASL version #x~x, ~s is now #x~x."
  116.             fver 'fasl-version fasl-version)
  117.     (setq *fasl-min-version* (min fver *fasl-min-version*)
  118.           *fasl-max-version* (max fver *fasl-max-version*)))
  119.   (symbol-macrolet ((array-type '(array (signed-byte 16))))
  120.     (let* ((imms (if (typep imms '(array t))
  121.                    imms
  122.                    (coerce imms '(array t))))
  123.            (imms-length (length imms))
  124.            (icode (if (typep icode array-type)
  125.                     icode
  126.                     (coerce icode array-type)))
  127.            (icode-bytes (* 2 (length icode)))
  128.            (linkmap (if (typep linkmap array-type)
  129.                       linkmap
  130.                       (coerce icode array-type)))
  131.            (linkmap-length (length linkmap))
  132.            (bits (require-type bits 'fixnum))
  133.            (attrib (require-type attrib 'fixnum)))
  134.       (unless (evenp linkmap-length)
  135.         (error "~s has an odd number of elements." linkmap))
  136.       (do ((i 0 (+ i 2)))
  137.           ((>= i linkmap-length))
  138.         (declare (fixnum i))
  139.         (let ((offset (aref linkmap i))
  140.               (type (aref linkmap (the fixnum (1+ i)))))
  141.           (declare (fixnum offset))
  142.           (unless (eql type $lm_longimm)
  143.             (error "Type code ~s is not ~s" type $lm_longimm))
  144.           (unless (and (evenp offset) (< -1 offset icode-bytes))
  145.             (error "Offset ~s odd or out of range." offset))
  146.           (setq offset (ash offset -1))
  147.           (let ((sym-adjust (aref icode offset))
  148.                 (imms-index (aref icode (the fixnum (1+ offset)))))
  149.             (declare (fixnum sym-adjust imms-index))
  150.             (unless (and (< -1 imms-index imms-length)
  151.                          (or (eql sym-adjust 0)
  152.                              (and (symbolp (aref imms imms-index))
  153.                                   (or (eql sym-adjust 8)
  154.                                       (eql sym-adjust 16)))))
  155.               (error "Malformed immediate specifier at index ~s in ~s"
  156.                      offset icode)))))
  157.       (%make-lfun imms icode linkmap bits attrib))))